home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Internals / Search.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  11.3 KB  |  343 lines
  1. package CPANPLUS::Internals::Search;
  2.  
  3. use strict;
  4.  
  5. use CPANPLUS::Error;
  6. use CPANPLUS::Internals::Constants;
  7. use CPANPLUS::Module;
  8. use CPANPLUS::Module::Author;
  9.  
  10. use File::Find;
  11. use File::Spec;
  12.  
  13. use Params::Check               qw[check allow];
  14. use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  15.  
  16. $Params::Check::VERBOSE = 1;
  17.  
  18. =pod
  19.  
  20. =head1 NAME
  21.  
  22. CPANPLUS::Internals::Search
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.     my $aref = $cpan->_search_module_tree(
  27.                         type    => 'package',
  28.                         allow   => [qr/DBI/],
  29.                     );
  30.  
  31.     my $aref = $cpan->_search_author_tree(
  32.                         type    => 'cpanid',
  33.                         data    => \@old_results,
  34.                         verbose => 1,
  35.                         allow   => [qw|KANE AUTRIJUS|],
  36.                     );
  37.  
  38.     my $aref = $cpan->_all_installed( );
  39.  
  40. =head1 DESCRIPTION
  41.  
  42. The functions in this module are designed to find module(objects)
  43. based on certain criteria and return them.
  44.  
  45. =head1 METHODS
  46.  
  47. =head2 _search_module_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] )
  48.  
  49. Searches the moduletree for module objects matching the criteria you
  50. specify. Returns an array ref of module objects on success, and false
  51. on failure.
  52.  
  53. It takes the following arguments:
  54.  
  55. =over 4
  56.  
  57. =item type
  58.  
  59. This can be any of the accessors for the C<CPANPLUS::Module> objects.
  60. This is a required argument.
  61.  
  62. =item allow
  63.  
  64. A set of rules, or more precisely, a list of regexes (via C<qr//> or
  65. plain strings), that the C<type> must adhere too. You can specify as
  66. many as you like, and it will be treated as an C<OR> search.
  67. For an C<AND> search, see the C<data> argument.
  68.  
  69. This is a required argument.
  70.  
  71. =item data
  72.  
  73. An arrayref of previous search results. This is the way to do an C<AND>
  74. search -- C<_search_module_tree> will only search the module objects
  75. specified in C<data> if provided, rather than the moduletree itself.
  76.  
  77. =back
  78.  
  79. =cut
  80.  
  81. # Although the Params::Check solution is more graceful, it is WAY too slow.
  82. #
  83. # This sample script:
  84. #
  85. #     use CPANPLUS::Backend;
  86. #     my $cb = new CPANPLUS::Backend;
  87. #     $cb->module_tree;
  88. #     my @list = $cb->search( type => 'module', allow => [qr/^Acme/] );
  89. #     print $_->module, $/ for @list;
  90. #
  91. # Produced the following output using Dprof WITH params::check code
  92. #
  93. #     Total Elapsed Time = 3.670024 Seconds
  94. #       User+System Time = 3.390373 Seconds
  95. #     Exclusive Times
  96. #     %Time ExclSec CumulS #Calls sec/call Csec/c  Name
  97. #      88.7   3.008  4.463  20610   0.0001 0.0002  Params::Check::check
  98. #      47.4   1.610  1.610      1   1.6100 1.6100  Storable::net_pstore
  99. #      25.6   0.869  0.737  20491   0.0000 0.0000  Locale::Maketext::Simple::_default
  100. #                                                  _gettext
  101. #      23.2   0.789  0.524  40976   0.0000 0.0000  Params::Check::_who_was_it
  102. #      23.2   0.789  0.677  20610   0.0000 0.0000  Params::Check::_sanity_check
  103. #      19.7   0.670  0.670      1   0.6700 0.6700  Storable::pretrieve
  104. #      14.1   0.480  0.211  41350   0.0000 0.0000  Params::Check::_convert_case
  105. #      11.5   0.390  0.256  20610   0.0000 0.0000  Params::Check::_hashdefs
  106. #      11.5   0.390  0.255  20697   0.0000 0.0000  Params::Check::_listreqs
  107. #      11.4   0.389  0.177  20653   0.0000 0.0000  Params::Check::_canon_key
  108. #      10.9   0.370  0.356  20697   0.0000 0.0000  Params::Check::_hasreq
  109. #      8.02   0.272  4.750      1   0.2723 4.7501  CPANPLUS::Internals::Search::_sear
  110. #                                                  ch_module_tree
  111. #      6.49   0.220  0.086  20653   0.0000 0.0000  Params::Check::_iskey
  112. #      6.19   0.210  0.077  20488   0.0000 0.0000  Params::Check::_store_error
  113. #      5.01   0.170  0.036  20680   0.0000 0.0000  CPANPLUS::Module::__ANON__
  114. #
  115. # and this output /without/
  116. #
  117. #     Total Elapsed Time = 2.803426 Seconds
  118. #       User+System Time = 2.493426 Seconds
  119. #     Exclusive Times
  120. #     %Time ExclSec CumulS #Calls sec/call Csec/c  Name
  121. #      56.9   1.420  1.420      1   1.4200 1.4200  Storable::net_pstore
  122. #      25.6   0.640  0.640      1   0.6400 0.6400  Storable::pretrieve
  123. #      9.22   0.230  0.096  20680   0.0000 0.0000  CPANPLUS::Module::__ANON__
  124. #      7.06   0.176  0.272      1   0.1762 0.2719  CPANPLUS::Internals::Search::_sear
  125. #                                                  ch_module_tree
  126. #      3.21   0.080  0.098     10   0.0080 0.0098  IPC::Cmd::BEGIN
  127. #      1.60   0.040  0.205     13   0.0031 0.0158  CPANPLUS::Internals::BEGIN
  128. #      1.20   0.030  0.030     29   0.0010 0.0010  vars::BEGIN
  129. #      1.20   0.030  0.117     10   0.0030 0.0117  Log::Message::BEGIN
  130. #      1.20   0.030  0.029      9   0.0033 0.0033  CPANPLUS::Internals::Search::BEGIN
  131. #      0.80   0.020  0.020      5   0.0040 0.0040  DynaLoader::dl_load_file
  132. #      0.80   0.020  0.127     10   0.0020 0.0127  CPANPLUS::Module::BEGIN
  133. #      0.80   0.020  0.389      2   0.0099 0.1944  main::BEGIN
  134. #      0.80   0.020  0.359     12   0.0017 0.0299  CPANPLUS::Backend::BEGIN
  135. #      0.40   0.010  0.010     30   0.0003 0.0003  Config::FETCH
  136. #      0.40   0.010  0.010     18   0.0006 0.0005  Locale::Maketext::Simple::load_loc
  137. #
  138.  
  139. sub _search_module_tree {
  140.     my $self = shift;
  141.     my $conf = $self->configure_object;
  142.     my %hash = @_;
  143.  
  144.     my($mods,$list,$verbose,$type);
  145.     my $tmpl = {
  146.         data    => { default    => [values %{$self->module_tree}],
  147.                      strict_type=> 1, store     => \$mods },
  148.         allow   => { required   => 1, default   => [ ], strict_type => 1,
  149.                      store      => \$list },
  150.         verbose => { default    => $conf->get_conf('verbose'),
  151.                      store      => \$verbose },
  152.         type    => { required   => 1, allow => [CPANPLUS::Module->accessors()],
  153.                      store      => \$type },
  154.     };
  155.  
  156.     my $args = check( $tmpl, \%hash ) or return;
  157.  
  158.     {   local $Params::Check::VERBOSE = 0;
  159.  
  160.         my @rv;
  161.         for my $mod (@$mods) {
  162.             #push @rv, $mod if check(
  163.             #                        { $type => { allow => $list } },
  164.             #                        { $type => $mod->$type() }
  165.             #                    );
  166.             push @rv, $mod if allow( $mod->$type() => $list );
  167.  
  168.         }
  169.         return \@rv;
  170.     }
  171. }
  172.  
  173. =pod
  174.  
  175. =head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] )
  176.  
  177. Searches the authortree for author objects matching the criteria you
  178. specify. Returns an array ref of author objects on success, and false
  179. on failure.
  180.  
  181. It takes the following arguments:
  182.  
  183. =over 4
  184.  
  185. =item type
  186.  
  187. This can be any of the accessors for the C<CPANPLUS::Module::Author>
  188. objects. This is a required argument.
  189.  
  190. =item allow
  191.  
  192.  
  193. A set of rules, or more precisely, a list of regexes (via C<qr//> or
  194. plain strings), that the C<type> must adhere too. You can specify as
  195. many as you like, and it will be treated as an C<OR> search.
  196. For an C<AND> search, see the C<data> argument.
  197.  
  198. This is a required argument.
  199.  
  200. =item data
  201.  
  202. An arrayref of previous search results. This is the way to do an C<and>
  203. search -- C<_search_author_tree> will only search the author objects
  204. specified in C<data> if provided, rather than the authortree itself.
  205.  
  206. =back
  207.  
  208. =cut
  209.  
  210. sub _search_author_tree {
  211.     my $self = shift;
  212.     my $conf = $self->configure_object;
  213.     my %hash = @_;
  214.  
  215.     my($authors,$list,$verbose,$type);
  216.     my $tmpl = {
  217.         data    => { default    => [values %{$self->author_tree}],
  218.                      strict_type=> 1, store     => \$authors },
  219.         allow   => { required   => 1, default   => [ ], strict_type => 1,
  220.                      store      => \$list },
  221.         verbose => { default    => $conf->get_conf('verbose'),
  222.                      store      => \$verbose },
  223.         type    => { required   => 1, allow => [CPANPLUS::Module::Author->accessors()],
  224.                      store      => \$type },
  225.     };
  226.  
  227.     my $args = check( $tmpl, \%hash ) or return;
  228.  
  229.     {   local $Params::Check::VERBOSE = 0;
  230.  
  231.         my @rv;
  232.         for my $auth (@$authors) {
  233.             #push @rv, $auth if check(
  234.             #                        { $type => { allow => $list } },
  235.             #                        { $type => $auth->$type }
  236.             #                    );
  237.             push @rv, $auth if allow( $auth->$type() => $list );
  238.         }
  239.         return \@rv;
  240.     }
  241.  
  242.  
  243. }
  244.  
  245. =pod
  246.  
  247. =head2 _all_installed()
  248.  
  249. This function returns an array ref of module objects of modules that
  250. are installed on this system.
  251.  
  252. =cut
  253.  
  254. sub _all_installed {
  255.     my $self = shift;
  256.     my $conf = $self->configure_object;
  257.     my %hash = @_;
  258.  
  259.     ### File::Find uses follow_skip => 1 by default, which doesn't die
  260.     ### on duplicates, unless they are directories or symlinks.
  261.     ### Ticket #29796 shows this code dying on Alien::WxWidgets,
  262.     ### which uses symlinks.
  263.     ### File::Find doc says to use follow_skip => 2 to ignore duplicates
  264.     ### so this will stop it from dying.
  265.     my %find_args = ( follow_skip => 2 );
  266.  
  267.     ### File::Find uses lstat, which quietly becomes stat on win32
  268.     ### it then uses -l _ which is not allowed by the statbuffer because
  269.     ### you did a stat, not an lstat (duh!). so don't tell win32 to
  270.     ### follow symlinks, as that will break badly
  271.     $find_args{'follow_fast'} = 1 unless ON_WIN32;
  272.  
  273.     ### never use the @INC hooks to find installed versions of
  274.     ### modules -- they're just there in case they're not on the
  275.     ### perl install, but the user shouldn't trust them for *other*
  276.     ### modules!
  277.     ### XXX CPANPLUS::inc is now obsolete, remove the calls
  278.     #local @INC = CPANPLUS::inc->original_inc;
  279.  
  280.     my %seen; my @rv;
  281.     for my $dir (@INC ) {
  282.         next if $dir eq '.';
  283.  
  284.         ### not a directory after all 
  285.         ### may be coderef or some such
  286.         next unless -d $dir;
  287.  
  288.         ### make sure to clean up the directories just in case,
  289.         ### as we're making assumptions about the length
  290.         ### This solves rt.cpan issue #19738
  291.         
  292.         ### John M. notes: On VMS cannonpath can not currently handle 
  293.         ### the $dir values that are in UNIX format.
  294.         $dir = File::Spec->canonpath( $dir ) unless ON_VMS;
  295.         
  296.         ### have to use F::S::Unix on VMS, or things will break
  297.         my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
  298.  
  299.         ### XXX in some cases File::Find can actually die!
  300.         ### so be safe and wrap it in an eval.
  301.         eval { File::Find::find(
  302.             {   %find_args,
  303.                 wanted      => sub {
  304.  
  305.                     return unless /\.pm$/i;
  306.                     my $mod = $File::Find::name;
  307.  
  308.                     ### make sure it's in Unix format, as it
  309.                     ### may be in VMS format on VMS;
  310.                     $mod = VMS::Filespec::unixify( $mod ) if ON_VMS;                    
  311.                     
  312.                     $mod = substr($mod, length($dir) + 1, -3);
  313.                     $mod = join '::', $file_spec->splitdir($mod);
  314.  
  315.                     return if $seen{$mod}++;
  316.  
  317.                     my $modobj = $self->module_tree($mod);
  318.                     
  319.                     ### seperate return, a list context return with one ''
  320.                     ### in it, is also true!
  321.                     return unless $modobj;
  322.  
  323.                     push @rv, $modobj;
  324.                 },
  325.             }, $dir
  326.         ) };
  327.  
  328.         ### report the error if file::find died
  329.         error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
  330.     }
  331.  
  332.     return \@rv;
  333. }
  334.  
  335. 1;
  336.  
  337. # Local variables:
  338. # c-indentation-style: bsd
  339. # c-basic-offset: 4
  340. # indent-tabs-mode: nil
  341. # End:
  342. # vim: expandtab shiftwidth=4:
  343.